home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / richte1a / frmmain.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1999-10-05  |  19.3 KB  |  596 lines
  1. VERSION 5.00
  2. Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"
  3. Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
  4. Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
  5. Begin VB.Form frmMain 
  6.    BorderStyle     =   1  'Fixed Single
  7.    Caption         =   "Rich Text IP Chat"
  8.    ClientHeight    =   3450
  9.    ClientLeft      =   45
  10.    ClientTop       =   330
  11.    ClientWidth     =   4380
  12.    LinkTopic       =   "Form1"
  13.    MaxButton       =   0   'False
  14.    ScaleHeight     =   3450
  15.    ScaleWidth      =   4380
  16.    StartUpPosition =   3  'Windows Default
  17.    Begin MSWinsockLib.Winsock sckConnect 
  18.       Left            =   3960
  19.       Top             =   3000
  20.       _ExtentX        =   741
  21.       _ExtentY        =   741
  22.       _Version        =   393216
  23.    End
  24.    Begin RichTextLib.RichTextBox rtbChat 
  25.       Height          =   1660
  26.       Left            =   80
  27.       TabIndex        =   18
  28.       Top             =   190
  29.       Width           =   4215
  30.       _ExtentX        =   7435
  31.       _ExtentY        =   2910
  32.       _Version        =   393217
  33.       Enabled         =   -1  'True
  34.       ReadOnly        =   -1  'True
  35.       ScrollBars      =   2
  36.       TextRTF         =   $"frmMain.frx":0000
  37.    End
  38.    Begin MSComDlg.CommonDialog dlgColors 
  39.       Left            =   3480
  40.       Top             =   3000
  41.       _ExtentX        =   847
  42.       _ExtentY        =   847
  43.       _Version        =   393216
  44.    End
  45.    Begin VB.CommandButton cmdColors 
  46.       Height          =   320
  47.       Left            =   2040
  48.       Picture         =   "frmMain.frx":00EF
  49.       Style           =   1  'Graphical
  50.       TabIndex        =   17
  51.       Top             =   1930
  52.       Width           =   315
  53.    End
  54.    Begin RichTextLib.RichTextBox rtbText 
  55.       Height          =   360
  56.       Left            =   -5
  57.       TabIndex        =   16
  58.       Top             =   2240
  59.       Width           =   3720
  60.       _ExtentX        =   6562
  61.       _ExtentY        =   635
  62.       _Version        =   393217
  63.       Enabled         =   -1  'True
  64.       TextRTF         =   $"frmMain.frx":0431
  65.       BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
  66.          Name            =   "Arial"
  67.          Size            =   9.75
  68.          Charset         =   0
  69.          Weight          =   400
  70.          Underline       =   0   'False
  71.          Italic          =   0   'False
  72.          Strikethrough   =   0   'False
  73.       EndProperty
  74.    End
  75.    Begin VB.CheckBox chkUnderline 
  76.       Height          =   320
  77.       Left            =   3120
  78.       Picture         =   "frmMain.frx":0520
  79.       Style           =   1  'Graphical
  80.       TabIndex        =   15
  81.       Top             =   1930
  82.       Width           =   315
  83.    End
  84.    Begin VB.CheckBox chkItalic 
  85.       Height          =   320
  86.       Left            =   2815
  87.       Picture         =   "frmMain.frx":0862
  88.       Style           =   1  'Graphical
  89.       TabIndex        =   14
  90.       Top             =   1930
  91.       Width           =   315
  92.    End
  93.    Begin VB.ComboBox cmbFonts 
  94.       Height          =   315
  95.       Left            =   10
  96.       Sorted          =   -1  'True
  97.       Style           =   2  'Dropdown List
  98.       TabIndex        =   13
  99.       Top             =   1930
  100.       Width           =   1935
  101.    End
  102.    Begin VB.CheckBox chkBold 
  103.       Height          =   320
  104.       Left            =   2520
  105.       Picture         =   "frmMain.frx":0BA4
  106.       Style           =   1  'Graphical
  107.       TabIndex        =   12
  108.       Top             =   1930
  109.       UseMaskColor    =   -1  'True
  110.       Width           =   315
  111.    End
  112.    Begin VB.CommandButton cmdConnect 
  113.       Caption         =   "Connect"
  114.       Height          =   405
  115.       Left            =   3390
  116.       TabIndex        =   11
  117.       Top             =   2655
  118.       Width           =   975
  119.    End
  120.    Begin VB.TextBox txtIP 
  121.       Height          =   285
  122.       Left            =   1960
  123.       TabIndex        =   10
  124.       Text            =   "localhost"
  125.       Top             =   3120
  126.       Width           =   1415
  127.    End
  128.    Begin VB.TextBox txtPort 
  129.       Height          =   285
  130.       Left            =   440
  131.       TabIndex        =   8
  132.       Text            =   "400"
  133.       Top             =   3120
  134.       Width           =   1215
  135.    End
  136.    Begin VB.OptionButton optHostGuest 
  137.       Caption         =   "Guest"
  138.       Height          =   195
  139.       Index           =   1
  140.       Left            =   2520
  141.       TabIndex        =   6
  142.       Top             =   2760
  143.       Value           =   -1  'True
  144.       Width           =   735
  145.    End
  146.    Begin VB.OptionButton optHostGuest 
  147.       Caption         =   "Host"
  148.       Height          =   195
  149.       Index           =   0
  150.       Left            =   1800
  151.       TabIndex        =   5
  152.       Top             =   2760
  153.       Width           =   735
  154.    End
  155.    Begin VB.TextBox txtNick 
  156.       Height          =   285
  157.       Left            =   440
  158.       TabIndex        =   4
  159.       Text            =   "NickName"
  160.       Top             =   2700
  161.       Width           =   1215
  162.    End
  163.    Begin VB.CommandButton cmdSend 
  164.       Caption         =   "Send"
  165.       Height          =   335
  166.       Left            =   3720
  167.       TabIndex        =   2
  168.       Top             =   2245
  169.       Width           =   625
  170.    End
  171.    Begin VB.Frame frmeSep 
  172.       Height          =   135
  173.       Left            =   0
  174.       TabIndex        =   1
  175.       Top             =   2520
  176.       Width           =   4385
  177.    End
  178.    Begin VB.Frame frmeChatWindow 
  179.       Caption         =   "Chat Window"
  180.       Height          =   1935
  181.       Left            =   0
  182.       TabIndex        =   0
  183.       Top             =   0
  184.       Width           =   4365
  185.    End
  186.    Begin VB.Shape shpGreen 
  187.       BackColor       =   &H00008000&
  188.       BackStyle       =   1  'Opaque
  189.       BorderColor     =   &H00008000&
  190.       Height          =   255
  191.       Left            =   3960
  192.       Shape           =   3  'Circle
  193.       Top             =   3120
  194.       Width           =   255
  195.    End
  196.    Begin VB.Shape shpRed 
  197.       BackColor       =   &H000000FF&
  198.       BackStyle       =   1  'Opaque
  199.       BorderColor     =   &H000000FF&
  200.       FillColor       =   &H00000080&
  201.       Height          =   255
  202.       Left            =   3480
  203.       Shape           =   3  'Circle
  204.       Top             =   3120
  205.       Width           =   255
  206.    End
  207.    Begin VB.Label lblIP 
  208.       BackStyle       =   0  'Transparent
  209.       Caption         =   "IP:"
  210.       Height          =   255
  211.       Left            =   1710
  212.       TabIndex        =   9
  213.       Top             =   3150
  214.       Width           =   255
  215.    End
  216.    Begin VB.Label lblPort 
  217.       BackStyle       =   0  'Transparent
  218.       Caption         =   "Port:"
  219.       Height          =   255
  220.       Left            =   0
  221.       TabIndex        =   7
  222.       Top             =   3150
  223.       Width           =   375
  224.    End
  225.    Begin VB.Line lneSep3 
  226.       BorderColor     =   &H80000003&
  227.       Index           =   1
  228.       X1              =   3345
  229.       X2              =   3345
  230.       Y1              =   2640
  231.       Y2              =   3050
  232.    End
  233.    Begin VB.Line lneSep3 
  234.       BorderColor     =   &H00FFFFFF&
  235.       Index           =   0
  236.       X1              =   3360
  237.       X2              =   3360
  238.       Y1              =   2640
  239.       Y2              =   3060
  240.    End
  241.    Begin VB.Line lneSep2 
  242.       BorderColor     =   &H80000003&
  243.       Index           =   1
  244.       X1              =   1680
  245.       X2              =   1680
  246.       Y1              =   3025
  247.       Y2              =   2625
  248.    End
  249.    Begin VB.Line lneSep 
  250.       BorderColor     =   &H80000003&
  251.       Index           =   1
  252.       X1              =   0
  253.       X2              =   3360
  254.       Y1              =   3030
  255.       Y2              =   3030
  256.    End
  257.    Begin VB.Line lneSep2 
  258.       BorderColor     =   &H00FFFFFF&
  259.       Index           =   0
  260.       X1              =   1695
  261.       X2              =   1695
  262.       Y1              =   3045
  263.       Y2              =   2640
  264.    End
  265.    Begin VB.Line lneSep 
  266.       BorderColor     =   &H00FFFFFF&
  267.       Index           =   0
  268.       X1              =   0
  269.       X2              =   3360
  270.       Y1              =   3045
  271.       Y2              =   3045
  272.    End
  273.    Begin VB.Label lblNick 
  274.       BackStyle       =   0  'Transparent
  275.       Caption         =   "Nick: "
  276.       Height          =   255
  277.       Left            =   0
  278.       TabIndex        =   3
  279.       Top             =   2730
  280.       Width           =   495
  281.    End
  282. Attribute VB_Name = "frmMain"
  283. Attribute VB_GlobalNameSpace = False
  284. Attribute VB_Creatable = False
  285. Attribute VB_PredeclaredId = True
  286. Attribute VB_Exposed = False
  287. '**********************************************************
  288. '*          Rich Text IP Chat by Joseph Huntley           *
  289. '*               joseph_huntley@email.com                 *
  290. '*                http://joseph.vr9.com                   *
  291. '*                                                        *
  292. '*  Made:  October 6, 1999                                *
  293. '*  Level: Intermediate/Advanced                          *
  294. '**********************************************************
  295. '* Notes: This is an expanded version of my original IP   *
  296. '*        chat example. The only difference is that this  *
  297. '*        version uses a richtextbox for colorful chat.   *
  298. '**********************************************************
  299. Private Const vbDarkRed = &H80&
  300. Private Const vbDarkGreen = &H8000&
  301. Private Sub chkBold_Click()
  302.    'toggle bold
  303.    If chkBold.Value = vbChecked Then
  304.       rtbText.SelBold = True
  305.    Else
  306.       rtbText.SelBold = False
  307.    End If
  308.  rtbText.SetFocus
  309. End Sub
  310. Private Sub chkItalic_Click()
  311.    'toggle italic
  312.    If chkItalic.Value = vbChecked Then
  313.       rtbText.SelItalic = True
  314.    Else
  315.       rtbText.SelItalic = False
  316.    End If
  317.  rtbText.SetFocus
  318. End Sub
  319. Private Sub chkUnderline_Click()
  320.    'toggle underline
  321.    If chkUnderline.Value = vbChecked Then
  322.       rtbText.SelUnderline = True
  323.    Else
  324.       rtbText.SelUnderline = False
  325.    End If
  326.  rtbText.SetFocus
  327. End Sub
  328. Private Sub cmbFonts_Click()
  329.   On Error Resume Next
  330.   'set the font
  331.   rtbText.SelFontName = cmbFonts.List(cmbFonts.ListIndex)
  332.   rtbText.SetFocus
  333. End Sub
  334. Private Sub cmdColors_Click()
  335. On Error GoTo ErrorHandler
  336. dlgColors.CancelError = True
  337. dlgColors.ShowColor
  338. rtbText.SelColor = dlgColors.Color
  339. rtbText.SetFocus
  340. ErrorHandler: 'user click 'Cancel'
  341. End Sub
  342. Private Sub cmdSend_Click()
  343.   Dim strRTF As String, strFontName As String, lngFontColor As Long, lngFontSize As Long
  344.   Dim blnBold As Boolean, blnUnderline As Boolean, blnItalic As Boolean
  345.     ''check if connected to someone
  346.     If sckConnect.State = sckClosed Then
  347.        MsgBox "You must be connected to someone."
  348.        Exit Sub
  349.     End If
  350.   ''get font-styles so we can reset them later
  351.   blnBold = rtbText.SelBold
  352.   blnUnderline = rtbText.SelUnderline
  353.   blnItalic = rtbText.SelItalic
  354.   lngFontColor& = rtbText.SelColor
  355.   lngFontSize& = rtbText.SelFontSize
  356.   strFontName$ = rtbText.SelFontName
  357.   ''format text w/ nick and assign rtf to strRTF$
  358.   rtbText.SelStart = 0
  359.   rtbText.SelLength = 0
  360.   rtbText.SelText = vbCrLf & txtNick.Text & ":" & vbTab
  361.   rtbText.SelStart = 0
  362.   rtbText.SelLength = Len(txtNick.Text) + 4 '4 = Length of vbCrLf + ':' + vbTab
  363.   rtbText.SelColor = vbBlue
  364.   rtbText.SelFontSize = 8
  365.   rtbText.SelFontName = "Arial"
  366.   rtbText.SelBold = True
  367.   rtbText.SelUnderline = False
  368.   rtbText.SelItalic = False
  369.   rtbText.SelStart = 0
  370.   rtbText.SelLength = 0
  371.   strRTF$ = rtbText.TextRTF
  372.   ''clear textbox
  373.   rtbText.Text = ""
  374.   ''reset font-styles
  375.   rtbText.SelBold = blnBold
  376.   rtbText.SelUnderline = blnUnderline
  377.   rtbText.SelItalic = blnItalic
  378.   rtbText.SelColor = lngFontColor&
  379.   rtbText.SelFontSize = lngFontSize&
  380.   rtbText.SelFontName = strFontName$
  381.   ''show bottom half of textbox
  382.   rtbChat.SelStart = Len(rtbChat.Text)
  383.   rtbChat.SelLength = 0
  384.   'print text in our rtbChat
  385.   rtbChat.SelRTF = strRTF$
  386.   'scroll rtbChat down
  387.   rtbChat.SelStart = Len(rtbChat.Text)
  388.   rtbChat.SelLength = 0
  389.   'set focus
  390.   rtbText.SetFocus
  391.   ''Send text to other person
  392.   Call sckConnect.SendData(strRTF$)
  393. End Sub
  394. Private Sub Form_Load()
  395.  Dim intBuffer As Integer, strFont As String
  396.    'load printer fonts to combobox
  397.    If Dir$(App.Path & "\fonts.dat") = "" Then
  398.         'font file doesnt exist. Create it.
  399.         Open App.Path & "\fonts.dat" For Output As #1
  400.              For intBuffer% = 0 To Printer.FontCount - 1
  401.                 Call cmbFonts.AddItem(Printer.Fonts(intBuffer%))
  402.                 Print #1, Printer.Fonts(intBuffer%)
  403.              Next intBuffer%
  404.         Close #1
  405.    Else
  406.         'load fonts from file
  407.         Open App.Path & "\fonts.dat" For Input As #1
  408.              While Not EOF(1)
  409.                 Input #1, strFont$
  410.                 Call cmbFonts.AddItem(strFont$)
  411.              Wend
  412.         Close #1
  413.    End If
  414.  cmbFonts.ListIndex = 0
  415.  ''cmbFonts.Sorted = True 'Alphabetize list
  416.   'set combobox to "Arial"
  417.   For intBuffer% = 0 To cmbFonts.ListCount - 1
  418.     If cmbFonts.List(intBuffer%) = "Arial" Then cmbFonts.ListIndex = intBuffer%: Exit For
  419.   Next intBuffer%
  420.   'set rtbText's font-styles
  421.   rtbText.SelBold = False
  422.   rtbText.SelUnderline = False
  423.   rtbText.SelItalic = False
  424.   rtbText.SelColor = vbBlack
  425.   rtbText.SelFontName = cmbFonts.List(cmbFonts.ListIndex)
  426.   rtbText.SelFontSize = 10
  427. End Sub
  428. Private Sub rtbText_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  429.   'check if text has a certain font-style and set checkboxes
  430.   'to the current font-style
  431.    If rtbText.SelBold = True Then
  432.       chkBold.Value = vbChecked
  433.    Else
  434.       chkBold.Value = vbUnchecked
  435.    End If
  436.    If rtbText.SelItalic = True Then
  437.       chkItalic.Value = vbChecked
  438.    Else
  439.       chkItalic.Value = vbUnchecked
  440.    End If
  441.    If rtbText.SelUnderline = True Then
  442.       chkUnderline.Value = vbChecked
  443.    Else
  444.       chkUnderline.Value = vbUnchecked
  445.    End If
  446. End Sub
  447. Private Sub sckConnect_Close()
  448.    cmdConnect_Click 'Reset everything
  449. End Sub
  450. Private Sub sckConnect_Connect()
  451.         ''turn from red to green light
  452.         shpRed.BackColor = vbDarkRed
  453.         shpRed.BorderColor = vbDarkRed
  454.         shpGreen.BackColor = vbGreen
  455.         shpGreen.BorderColor = vbGreen
  456.         
  457.         ''write "*** Connected".
  458.         rtbChat.SelStart = Len(rtbChat.Text)
  459.         rtbChat.SelLength = 0
  460.         rtbChat.SelText = "*** Connected"
  461.         rtbChat.SelStart = Len(rtbChat.Text)
  462.         rtbChat.SelLength = Len("*** Connected")
  463.         rtbChat.SelColor = vbRed
  464.         rtbChat.SelBold = False
  465.         rtbChat.SelFontName = "Courier New"
  466.         rtbChat.SelFontSize = 10
  467.         rtbChat.SelStart = Len(rtbChat.Text)
  468.         rtbChat.SelLength = 0
  469.         
  470. End Sub
  471. Private Sub sckConnect_ConnectionRequest(ByVal requestID As Long)
  472.    ''check if connected to something else. If so, close that connection
  473.    If sckConnect.State <> sckClosed Then sckConnect.Close
  474.    'accept the connection
  475.    Call sckConnect.Accept(requestID&)
  476.    sckConnect_Connect 'fire 'Connect' event
  477. End Sub
  478. Private Sub sckConnect_DataArrival(ByVal bytesTotal As Long)
  479.    Dim strData As String, strBuf As String
  480.    Dim strNewNick As String
  481.    'get RTF string to add
  482.    Call sckConnect.GetData(strData$, vbString)
  483.          
  484.    'set selpostioning
  485.    rtbChat.SelStart = Len(rtbChat.Text)
  486.    rtbChat.SelLength = 0
  487.    'print text
  488.    rtbChat.SelRTF = strData$
  489.    'make textbox scroll
  490.    rtbChat.SelStart = Len(rtbChat.Text)
  491.    rtbChat.SelLength = 0
  492. End Sub
  493. Private Sub cmdConnect_Click()
  494.   Dim strIP As String
  495.     If cmdConnect.Caption = "Connect" Or cmdConnect.Caption = "Listen" Then
  496.        txtPort.Enabled = False
  497.        txtNick.Enabled = False
  498.        optHostGuest(0).Enabled = False
  499.        optHostGuest(1).Enabled = False
  500.        cmdConnect.Caption = "Disconnect"
  501.     Else
  502.        txtPort.Enabled = True
  503.        txtNick.Enabled = True
  504.        optHostGuest(0).Enabled = True
  505.        optHostGuest(1).Enabled = True
  506.        
  507.           If optHostGuest(0).Value = True Then
  508.              cmdConnect.Caption = "Listen"
  509.           Else
  510.              cmdConnect.Caption = "Connect"
  511.           End If
  512.           
  513.         sckConnect.Close
  514.         
  515.         ''turn from green to red light
  516.         shpRed.BackColor = vbRed
  517.         shpRed.BorderColor = vbRed
  518.         shpGreen.BackColor = vbDarkGreen
  519.         shpGreen.BorderColor = vbDarkGreen
  520.         ''write "*** Disconnected".
  521.         rtbChat.SelStart = Len(rtbChat.Text)
  522.         rtbChat.SelLength = 0
  523.         rtbChat.SelText = vbCrLf & "*** Disconnected"
  524.         rtbChat.SelStart = Len(rtbChat.Text) - Len(vbCrLf & "*** Disconnected")
  525.         rtbChat.SelLength = Len(vbCrLf & "*** Disconnected")
  526.         rtbChat.SelColor = vbRed
  527.         rtbChat.SelBold = False
  528.         rtbChat.SelFontName = "Courier New"
  529.         rtbChat.SelFontSize = 10
  530.         rtbChat.SelStart = Len(rtbChat.Text)
  531.         rtbChat.SelLength = 0
  532.         Exit Sub
  533.     End If
  534.     Select Case optHostGuest(0).Value
  535.         Case True:  'Host
  536.            ''listen for connections
  537.            sckConnect.LocalPort = CLng(txtPort.Text)
  538.            sckConnect.Listen
  539.            
  540.            ''write "*** Waiting for Connection."
  541.            rtbChat.Text = ""
  542.            rtbChat.SelStart = 0
  543.            rtbChat.SelLength = 0
  544.            rtbChat.SelText = "*** Waiting for connection..." & vbCrLf
  545.            rtbChat.SelStart = 0
  546.            rtbChat.SelLength = Len("*** Waiting for connection..." & vbCrLf)
  547.            rtbChat.SelColor = vbRed
  548.            rtbChat.SelBold = False
  549.            rtbChat.SelFontName = "Courier New"
  550.            rtbChat.SelFontSize = 10
  551.            rtbChat.SelStart = Len(rtbChat.Text)
  552.            rtbChat.SelLength = 0
  553.         Case False: 'Guest
  554.            ''try to connect
  555.            strIP$ = txtIP.Text
  556.            If LCase$(strIP$) = "localhost" Then strIP$ = sckConnect.LocalIP
  557.            sckConnect.Connect txtIP.Text, txtPort.Text
  558.            
  559.            ''write "*** Connecting".
  560.            rtbChat.Text = ""
  561.            rtbChat.SelStart = 0
  562.            rtbChat.SelLength = 0
  563.            rtbChat.SelText = "*** Connecting..." & vbCrLf
  564.            rtbChat.SelStart = 0
  565.            rtbChat.SelLength = Len("*** Connecting..." & vbCrLf)
  566.            rtbChat.SelColor = vbRed
  567.            rtbChat.SelBold = False
  568.            rtbChat.SelFontName = "Courier New"
  569.            rtbChat.SelFontSize = 10
  570.            rtbChat.SelStart = Len(rtbChat.Text)
  571.            rtbChat.SelLength = 0
  572.     End Select
  573.             
  574. End Sub
  575. Private Sub optHostGuest_Click(Index As Integer)
  576.     Select Case Index
  577.        Case 0: 'Host
  578.           txtIP.Text = sckConnect.LocalIP
  579.           txtIP.BackColor = &H8000000F  'Grey
  580.           txtIP.Locked = True
  581.           cmdConnect.Caption = "Listen"
  582.        Case 1: 'Guest
  583.           txtIP.Text = "localhost"
  584.           txtIP.BackColor = vbWhite
  585.           txtIP.Locked = False
  586.           cmdConnect.Caption = "Connect"
  587.           
  588.     End Select
  589. End Sub
  590. Private Sub rtbText_KeyPress(KeyAscii As Integer)
  591.    If KeyAscii = 13 Then 'If user pressed 'Enter'
  592.       cmdSend_Click 'click 'Send' button
  593.       KeyAscii = 0 'Make sure it doesnt write enter to rtbText
  594.    End If
  595. End Sub
  596.